# audit::browser --
#
#        Incr Tk based audit data browser.
#
#        This package shows audit information
#

namespace eval audit {}

package require tablelist
package require audit::audit
package require msgcat
package require Itcl
package require Itk

if {[info commands ::audit::Browser] != ""} {
    itcl::delete class ::audit::Browser
}

itcl::class ::audit::Browser {
    inherit itk::Widget

    private variable logdata [list]
    private variable textwrap
    private variable showmode
    private variable showdata

    private variable level0 1
    private variable level1 9

    private variable retype ""
    private variable remessage ""

    constructor {args} {
        itk_component add search {
            frame $itk_interior.search
        } {}

        itk_component add label_level0 {
            label $itk_interior.search.l_level0 -anchor e -text [msgcat::mc "Min level"]
        } {}

        itk_component add label_level1 {
            label $itk_interior.search.l_level1 -anchor e -text [msgcat::mc "Max level"]
        } {}

        itk_component add label_type {
            label $itk_interior.search.l_type -anchor e -text [msgcat::mc "Type"]
        } {}

        itk_component add label_message {
            label $itk_interior.search.l_message -anchor e -text [msgcat::mc "Message"]
        } {}

        itk_component add search_level0 {
            spinbox $itk_interior.search.level0 -from 1 -to 9 -textvariable [itcl::scope level0] -width 3
        } {}

        itk_component add search_level1 {
            spinbox $itk_interior.search.level1 -from 1 -to 9 -textvariable [itcl::scope level1] -width 3
        } {}

        itk_component add search_type {
            entry $itk_interior.search.type -textvariable [itcl::scope retype] -width 12
        } {}

        itk_component add search_message {
            entry $itk_interior.search.message -textvariable [itcl::scope remessage] -width 15
        } {}

        itk_component add eventlist {
            tablelist::tablelist $itk_interior.eventlist -yscrollcommand [list $itk_interior.eventlistvs set] -height 20 -width 80 -exportselection 0
        } {}

        itk_component add eventlistvs {
            scrollbar $itk_interior.eventlistvs -command [list $itk_interior.eventlist yview]
        } {}

        itk_component add paramlist {
            tablelist::tablelist $itk_interior.paramlist -yscrollcommand [list $itk_interior.paramlistvs set] -height 15 -width 30 -exportselection 0
        } {}

        itk_component add paramlistvs {
            scrollbar $itk_interior.paramlistvs -command [list $itk_interior.paramlist yview]
        } {}

        itk_component add varlist {
            tablelist::tablelist $itk_interior.varlist -yscrollcommand [list $itk_interior.varlistvs set] -height 15 -width 30 -exportselection 0
        } {}

        itk_component add varlistvs {
            scrollbar $itk_interior.varlistvs -command [list $itk_interior.varlist yview]
        } {}

        itk_component add stacklist {
            tablelist::tablelist $itk_interior.stacklist -yscrollcommand [list $itk_interior.stacklistvs set] -height 15 -width 20 -exportselection 0
        } {}

        itk_component add stacklistvs {
            scrollbar $itk_interior.stacklistvs -command [list $itk_interior.stacklist yview]
        } {}

        $itk_component(eventlist) configure -showseparators 1 \
            -columns [list 20 [msgcat::mc "Date and time"] right 6 [msgcat::mc "Level"] right 6 [msgcat::mc "Stack"] right 15 [msgcat::mc "Type"] left 10 [msgcat::mc "Message"] left 1 {} left]
        $itk_component(eventlist) columnconfigure 5 -hide 1
        $itk_component(eventlist) configure -stretch 4

        $itk_component(paramlist) configure \
            -columns [list 15 [msgcat::mc "Parameter"] left 10 [msgcat::mc "Value"] left 1 {} left]
        $itk_component(paramlist) columnconfigure 2 -hide 1
        $itk_component(paramlist) configure -stretch 1

        $itk_component(varlist) configure \
            -columns [list 15 [msgcat::mc "Variable"] left 10 [msgcat::mc "Value"] left 1 {} left]
        $itk_component(varlist) columnconfigure 2 -hide 1
        $itk_component(varlist) configure -stretch 1

        $itk_component(stacklist) configure \
            -columns [list 2 [msgcat::mc ""] right 10 [msgcat::mc "Command"] left 1 {} left]
        $itk_component(stacklist) columnconfigure 2 -hide 1
        $itk_component(stacklist) configure -stretch 1

        pack $itk_component(label_level0) $itk_component(search_level0) $itk_component(label_level1) $itk_component(search_level1) $itk_component(label_type) $itk_component(search_type) $itk_component(label_message) -side left
        pack $itk_component(search_message) -fill both -expand 1 -side right

        grid $itk_component(search) - - - - - -sticky news
        grid $itk_component(eventlist) - - - - $itk_component(eventlistvs) -sticky news
        grid $itk_component(paramlist) $itk_component(paramlistvs) $itk_component(varlist) $itk_component(varlistvs) $itk_component(stacklist) $itk_component(stacklistvs) -sticky news

        trace add variable [itcl::scope level0] write [itcl::code $this onTrace0]
        trace add variable [itcl::scope level1] write [itcl::code $this onTrace0]
        trace add variable [itcl::scope retype] write [itcl::code $this onTrace0]
        trace add variable [itcl::scope remessage] write [itcl::code $this onTrace0]

        grid columnconfigure $itk_interior 0 -weight 2
        grid columnconfigure $itk_interior 2 -weight 2
        grid columnconfigure $itk_interior 4 -weight 1
        grid rowconfigure $itk_interior 1 -weight 1
        grid rowconfigure $itk_interior 2 -weight 1

        set cmd [itcl::code $this checkSelection]

        bind selection-$itk_interior <Key> $cmd
        bind selection-$itk_interior <ButtonPress> $cmd
        bind selection-$itk_interior <ButtonRelease> $cmd
        bind selection-$itk_interior <B1-Motion> $cmd
        bind selection-$itk_interior <B2-Motion> $cmd
        bind selection-$itk_interior <B3-Motion> $cmd

        bind doubleclick-param-$itk_interior <ButtonRelease-1> [itcl::code $this doDoubleClick param 0 showParam]
        bind doubleclick-param-$itk_interior <Double-ButtonRelease-1> [itcl::code $this doDoubleClick param 1 showParam]
        bind doubleclick-var-$itk_interior <ButtonRelease-1> [itcl::code $this doDoubleClick var 0 showVar]
        bind doubleclick-var-$itk_interior <Double-ButtonRelease-1> [itcl::code $this doDoubleClick var 1 showVar]
        bind doubleclick-stack-$itk_interior <ButtonRelease-1> [itcl::code $this doDoubleClick stack 0 showStack]
        bind doubleclick-stack-$itk_interior <Double-ButtonRelease-1> [itcl::code $this doDoubleClick stack 1 showStack]

        bindtags $itk_component(paramlist).body [linsert [bindtags $itk_component(paramlist).body] end doubleclick-param-$itk_interior]
        bindtags $itk_component(varlist).body [linsert [bindtags $itk_component(varlist).body] end doubleclick-var-$itk_interior]
        bindtags $itk_component(stacklist).body [linsert [bindtags $itk_component(stacklist).body] end doubleclick-stack-$itk_interior]
        bindtags $itk_component(eventlist).body [linsert [bindtags $itk_component(eventlist).body] end selection-$itk_interior]

        eval itk_initialize $args
    }

    destructor {
        bind selection-$itk_interior <Key> {}
        bind selection-$itk_interior <ButtonPress> {}
        bind selection-$itk_interior <ButtonRelease> {}
        bind selection-$itk_interior <B1-Motion> {}
        bind selection-$itk_interior <B2-Motion> {}
        bind selection-$itk_interior <B3-Motion> {}

        after cancel $onTraceTimer

        if {[info exists livetimer]} {
            after cancel $livetimer
        }
        if {$islive} {
            _stopLive
        }
    }

    private variable dblclickdata
    private method doDoubleClick {widget isdouble cmd} {
        set idx -1; catch {set idx [$itk_component(${widget}list) index active]}
        if {$isdouble} {
            if {$dblclickdata($widget) != $idx} {return}
        }  else  {
            set dblclickdata($widget) $idx
            return
        }
        $cmd
    }

    private variable onTraceTimer ""
    private method onTrace0 {args} {
        after cancel $onTraceTimer
        set onTraceTimer [after 500 [itcl::code $this onTrace]]
    }

    private method onTrace {} {
        _refreshList
    }

    # loading from a file
    public method load {{filename ""}} {
        if {$filename == ""} {
            set filename [tk_getOpenFile -parent [winfo toplevel $itk_interior]]
            if {$filename == ""} {return}
        }

        set fh [open $filename r]
        fconfigure $fh -translation binary
        gets $fh header
        if {$header == "AUDIT.DUMP"} {
            set tmp [read $fh]
            close $fh
            set data [::audit::audit::decompress $tmp]
        }  elseif {$header == "AUDIT.RAW"} {
            set data [read $fh]
            close $fh
        }  else  {
            close $fh
            set ei "Unknown header - $header"
            return -code error -errorinfo $ei $ei
        }
        set logdata [encoding convertfrom utf-8 $data]
        _refreshList
    }

    # live auditing
    private variable islive 0
    private variable livetimer

    itk_option define -reverseorder reverseOrder ReverseOrder true {_refreshList}
    itk_option define -livelength liveLength LiveLength 500
    itk_option define -livelevel liveLevel LiveLevel ""
    itk_option define -liveregexp liveRegexp LiveRegexp ""

    itk_option define -live live Live false {
        if {$islive && (!$itk_option(-live))} {
            set islive 0
            _stopLive
        }  elseif {(!$islive) && $itk_option(-live)} {
            set islive 1
            _startLive
        }
    }

    private method _stopLive {} {
        audit::removeNotifier [itcl::code $this _notify]
    }

    private method _startLive {} {
        audit::addNotifier [itcl::code $this _notify]
        set logdata [audit::getlog $itk_option(-livelevel) $itk_option(-liveregexp) $itk_option(-livelength)]
        _refreshList
    }

    private method _notify {} {
        if {![info exists livetimer]} {
            set livetimer [after idle [itcl::code $this _notifyIdle]]
        }
    }

    private method _notifyIdle {} {
        unset livetimer
        # perhaps we are no longer monitoring 
        if {!$islive} {return}

        # TODO: compare last entry?
        set logdata [audit::getlog $itk_option(-livelevel) $itk_option(-liveregexp) $itk_option(-livelength)]

        _refreshList
    }

    # list handling
    itk_option define -maxlength maxLength MaxLength 1000

    private variable currentevent -1
    private method checkSelection {} {
        set idx -1; catch {set idx [lindex [$itk_component(eventlist) curselection] 0]}
        if {$idx == ""} {set idx -1}
        if {$idx != $currentevent} {
            set currentevent $idx
            showEvent $idx
        }
    }

    if {[info commands ::lreverse] == ""} {
        private proc _reverseList {l} {
            set r {}
            set i [llength $l]
            while {[incr i -1]} {lappend r [lindex $l $i]}
            lappend r [lindex $l 0]
            return $r
        }
    }  else  {
        private proc _reverseList {l} {
            return [lreverse $l]
        }
    }
    private method _refreshList {} {
        set rows [list]
        set cnt 0
        set cmd ""
        
        append cmd {
            foreach {clk0 clk1 type level message vars ar stacktrace} $row break
        }

        if {$level0 > 1} {
            append cmd "if \{\$level < $level0\} \{continue\}" \n
        }

        if {$level1 < 9} {
            append cmd "if \{\$level > $level1\} \{continue\}" \n
        }
        if {$retype != ""} {
            append cmd "if \{!\[regexp -nocase [list $retype] \$type\]\} \{continue\}" \n
        }
        if {$remessage != ""} {
            append cmd "if \{!\[regexp -nocase [list $remessage] \$message\]\} \{continue\}" \n
        }

        append cmd {
            set clk [format %s:%04d [clock format $clk0 -format "%y-%m-%d %H:%M:%S"] $clk1]
            lappend rows [list $clk $level [llength $stacktrace] $type $message [list $vars $ar $stacktrace]]
            if {[incr cnt] >= $itk_option(-maxlength)} {break}
        }

        foreach row $logdata $cmd

        $itk_component(eventlist) delete 0 end
        set rows [lrange $rows end-2000 end]
        if {$itk_option(-reverseorder)} {
            set rows [_reverseList $rows]
        }
        $itk_component(eventlist) insertlist end $rows

        clearVarlist
        clearParamlist
        clearStacktrace

        set currentevent -1
    }

    private method showEvent {idx} {
        if {$idx < 0} {
            clearVarlist
            clearParamlist
            clearStacktrace
            return
        }
        set data [lindex [$itk_component(eventlist) get $idx] end]
        foreach {vars params stack} $data break

        setVarlist $vars
        setParams $params
        setStacktrace $stack
    }

    # variable list
    private method clearVarlist {} {
        $itk_component(varlist) delete 0 end
    }
    private method setVarlist {v} {
        $itk_component(varlist) delete 0 end
        set idx 0
        foreach {name type value} $v {
            set param [list $type $value]
            if {$type == "array"} {
                if {[llength $value] == 0} {
                    set val "(nothing set)"
                }  else  {
                    set val "(...)"
                }
                $itk_component(varlist) insert end [list $name $val $param]
                $itk_component(varlist) cellconfigure $idx,1 -foreground {#0000ff}
            }  elseif {$type == "unset"} {
                set val "(unset)"
                $itk_component(varlist) insert end [list $name $val $param]
                $itk_component(varlist) cellconfigure $idx,1 -foreground {#0000ff}
            }  else  {
                set val [string range $value 0 199]
                $itk_component(varlist) insert end [list $name $val $param]
            }
            incr idx
        }
    }

    private method showVar {} {
        set idx [lindex [$itk_component(varlist) curselection] 0]
        # TODO: Tcl 8.3 compatible
        set d [$itk_component(varlist) get $idx]
        if {[lindex $d end 0] == "array"} {
            showAsData [msgcat::mc "Array \"%s\"" [lindex $d 0]] [lindex $d end 1] list2
        }  else  {
            showAsData [msgcat::mc "Variable \"%s\"" [lindex $d 0]] [lindex $d end 1] text1
        }
    }

    # param list
    private method clearParamlist {} {
        $itk_component(paramlist) delete 0 end
    }
    private method setParams {v} {
        $itk_component(paramlist) delete 0 end
        foreach {name value} $v {
            $itk_component(paramlist) insert end [list $name [string range $value 0 199] $value]
        }
    }
    private method showParam {} {
        set idx [lindex [$itk_component(paramlist) curselection] 0]
        set d [$itk_component(paramlist) get $idx]
        showAsData [msgcat::mc "Parameter \"%s\"" [lindex $d 0]] [lindex $d end] text1
    }

    # stack trace
    private method clearStacktrace {} {
        $itk_component(stacklist) delete 0 end
    }
    private method setStacktrace {v} {
        $itk_component(stacklist) delete 0 end
        set idx [llength $v]
        foreach v $v {
            incr idx -1
            $itk_component(stacklist) insert end [list $idx [string range $v 0 199] $v]
        }
    }
    private method showStack {} {
        set idx [lindex [$itk_component(stacklist) curselection] 0]
        set d [$itk_component(stacklist) get $idx]
        showAsData [msgcat::mc "Stack trace - %d" [lindex $d 0]] [lindex $d end] text1
    }

    # details window
    private method getwindow {} {
        if {[winfo exists $itk_interior.subwindow]} {
            foreach ch [winfo children $itk_interior.subwindow] {
                destroy $ch
            }
            return $itk_interior.subwindow
        }
        toplevel $itk_interior.subwindow
        set geo 300x400+[expr {(([winfo width $itk_interior] - 360) / 2) + [winfo rootx $itk_interior]}]+[expr {(([winfo height $itk_interior] - 420) / 2) + [winfo rooty $itk_interior]}]
        wm geometry $itk_interior.subwindow $geo
        wm transient $itk_interior.subwindow $itk_interior
        after idle [list catch [list wm attributes $itk_interior.subwindow -toolwindow 1]]
        return $itk_interior.subwindow
    }

    private method showAsData {title data mode} {
        set sub [getwindow]
        wm title $sub $title

        set showmode($sub) $mode
        set showdata($sub) $data

        set fsub [frame $sub.fsub]
        label $fsub.label -text [msgcat::mc "Wrap mode:"]
        radiobutton $fsub.mode0 -variable [itcl::scope showmode($sub)] -value text0 -command [itcl::code $this showAsDataMode $sub] -indicatoron 0 -text [msgcat::mc "No wrap"]
        radiobutton $fsub.mode1 -variable [itcl::scope showmode($sub)] -value text1 -command [itcl::code $this showAsDataMode $sub] -indicatoron 0 -text [msgcat::mc "Wrap"]
        radiobutton $fsub.mode2 -variable [itcl::scope showmode($sub)] -value list -command [itcl::code $this showAsDataMode $sub] -indicatoron 0 -text [msgcat::mc "List"]
        radiobutton $fsub.mode3 -variable [itcl::scope showmode($sub)] -value list2 -command [itcl::code $this showAsDataMode $sub] -indicatoron 0 -text [msgcat::mc "Name-value"]

        frame $sub.main

        pack $fsub.label $fsub.mode0 $fsub.mode1 $fsub.mode2 $fsub.mode3 -side left -fill y

        pack $sub.fsub -fill x
        pack $sub.main -fill both -expand 1

        showAsDataMode $sub
    }

    private method showAsDataMode {sub} {
        foreach ch [winfo children $sub.main] {
            destroy $ch
        }
        switch -- $showmode($sub) {
            text0 {
                text $sub.main.text -width 1 -height 1 -wrap none \
                    -xscrollcommand [list $sub.main.xscroll set] \
                    -yscrollcommand [list $sub.main.yscroll set]
                scrollbar $sub.main.xscroll -orient horizontal -command [list $sub.main.text xyiew]
                scrollbar $sub.main.yscroll -orient vertical -command [list $sub.main.text yview]

                $sub.main.text insert end $showdata($sub)
                $sub.main.text configure -state disabled
                
                grid $sub.main.text $sub.main.yscroll -sticky news
                grid $sub.main.xscroll -sticky news

                grid columnconfigure $sub.main 0 -weight 1
                grid rowconfigure $sub.main 0 -weight 1
            }
            text1 {
                text $sub.main.text -width 1 -height 1 -wrap word -exportselection 0 \
                    -yscrollcommand [list $sub.main.yscroll set]
                scrollbar $sub.main.yscroll -orient vertical -command [list $sub.main.text yview]

                $sub.main.text insert end $showdata($sub)
                $sub.main.text configure -state disabled
                
                grid $sub.main.text $sub.main.yscroll -sticky news

                grid columnconfigure $sub.main 0 -weight 1
                grid rowconfigure $sub.main 0 -weight 1
            }
            list {
                tablelist::tablelist $sub.main.list -width 1 -height 1 -exportselection 0 \
                    -yscrollcommand [list $sub.main.yscroll set] \
                    -stretch 0 -columns [list 10 [msgcat::mc "Value"] left]
                scrollbar $sub.main.yscroll -orient vertical -command [list $sub.main.list yview]

                foreach item $showdata($sub) {
                    $sub.main.list insert end [list $item]
                }
                
                grid $sub.main.list $sub.main.yscroll -sticky news

                grid columnconfigure $sub.main 0 -weight 1
                grid rowconfigure $sub.main 0 -weight 1
            }

            list2 {
                tablelist::tablelist $sub.main.list -width 1 -height 1 -exportselection 0 \
                    -yscrollcommand [list $sub.main.yscroll set] \
                    -stretch 1 -columns [list 10 [msgcat::mc "Name"] left 10 [msgcat::mc "Value"] left] \
                    -showseparators true -labelcommand tablelist::sortByColumn

                scrollbar $sub.main.yscroll -orient vertical -command [list $sub.main.list yview]

                foreach {i0 i1} $showdata($sub) {
                    $sub.main.list insert end [list $i0 $i1]
                }
                
                grid $sub.main.list $sub.main.yscroll -sticky news

                grid columnconfigure $sub.main 0 -weight 1
                grid rowconfigure $sub.main 0 -weight 1
            }
        }
    }
}

proc ::audit::browser {path args} {
    return [uplevel 1 [concat [list ::audit::Browser $path] $args]]
}

proc audit::showLiveBrowser {} {
    toplevel .auditbrowser
    ::audit::browser .auditbrowser.browser -live 1 -reverseorder true
    pack .auditbrowser.browser -fill both -expand 1
}

# handle browser
if {[info exists ::argv0] && [string equal $::argv0 [info script]]} {
    menu .menu -tearoff 0
    menu .menu.file -tearoff 0
    menu .menu.view -tearoff 0

    .menu add cascade -menu .menu.file -label [msgcat::mc "File"] -underline 0
    .menu add cascade -menu .menu.view -label [msgcat::mc "View"] -underline 0
    .menu.file add command -command {.browser load} -label [msgcat::mc "Load audit file"] -underline 0
    .menu.view add checkbutton -command {.browser configure -reverseorder $isreverse} \
        -variable isreverse -onvalue true -offvalue false \
        -label [msgcat::mc "Show in descending order"]

    set isreverse 0
    . configure -menu .menu
    ::audit::browser .browser -reverseorder $isreverse

    pack .browser -fill both -expand 1

    if {[llength $argv] > 0} {
        .browser load [lindex $argv 0]
    }

    wm title . "Audit browser"
}

package provide audit::browser 1.3
